unit uBasic ;

interface

uses
  Windows,
  Classes,
  Forms,
  Menus,
  Graphics,
  Contnrs,
  Types,
  SysUtils,
  VirtualTrees,
  GDIPOBJ,
  GDIPAPI ;

type

  ExceptionMeda = class( Exception ) ;
  EXML = class( Exception ) ;
  ExceptionMedaNode = class( Exception ) ;

  TMedaState = ( triFalse, triMaybe, TriTrue ) ;

  TMedaLogType = ( mltNone, mltException, mltPython ) ;

  TMedaTool = ( toolSelect, toolDraw, toolDrag, toolConnect ) ;

  TMedaDir = ( drEast, drNE, drNorth, drNW, drWest, drSW, drSouth, drSE ) ;

  TMedaDirSet = set of TMedaDir ;

  TMedaPortType = (
    pntNone,

    pntIO, pntIOInv,
    pntIn, pntInInv,
    pntOut, pntOutInv,

    pntClock,
    pntClockInv,

    pntPower,
    pntGround,

    pntAnalog,
    pntPassive,

    pntPortIn,
    pntPortOut,
    pntPortBidir
    ) ;

  TMedaPadType = ( ptyNone, ptyCircle, ptyOcta, ptyRect,
    ptyOblong, ptyFinger, ptyThermal, ptyFiducial, ptyMoire ) ;

  TMedaPowerType = ( pwtBar, pwtCircle, pwtGround, pwtEarth, pwtArrow ) ;

  TMedaFlag = ( vfDesignator, vfName, vfBody, vfPower ) ;
  TMedaFlagsSet = set of TMedaFlag ;

  TMedaLayerType = (
    lcNone = 0,
    lcMechanical,
    lcTopGlue, lcTopPaste, lcTopSilk,
    lcComponent, lcInner0, lcGround, lcInner1,
    lcInner2, lcPower, lcInner3, lcSolder,
    lcBottomSilk, lcBottomPaste, lcBottomGlue
    ) ;
  TMedaLayerSet = set of TMedaLayerType ;

  TMedaPageNumber = integer ;

  TIconType = (
    iconNone = 0, iconUnknown = 1,
    iconObject = 2, iconContainer = 3,

    iconProject = 4, iconModules = 5,

    iconModule = 6, iconPart = 7,
    iconNet = 8, iconPort = 9,

    iconBank = 10, iconPin = 11, iconPinBus = 12, iconPinBundle = 13,

    iconLine = 14, iconLabel = 15, iconBus = 16, iconBundle = 17,

    iconFootprint = 18, iconTrack = 19,
    iconVia = 20, iconStack = 21, iconPad = 22, iconCopper = 23,

    iconView = 24,
    iconSchematic = 25, iconPage = 36, iconPCB = 27, iconLayer = 28
    ) ;

  TFrameClass = class of TFrame ;

  TMedaViewable = class
  private
    fHandle : TGUID ;
    fName : string ;
    fExpanded : boolean ;
    fSelection : TMedaState ;
    procedure SetHandle( aHandle : TGUID ) ;
    function GetGUIDAsString : string ;
    procedure SetGUIDAsString( const Value : string ) ;
    procedure SetNode( const Value : PVirtualNode ) ;
    procedure SetVST( const Value : TBaseVirtualTree ) ;
  protected
    fVST : TBaseVirtualTree ;
    fNode : PVirtualNode ;
    fIndex : integer ;
  protected
    procedure Update ; virtual ;
    function GetPopupMenu : TPopupMenu ; virtual ;
  public
    function GetName : string ; virtual ;
    procedure SetName( const aName : string ) ; virtual ;
    property Name : string read GetName write SetName ;

    function GetSelection : TMedaState ; virtual ;
    procedure SetSelection( aFlag : TMedaState ) ; virtual ;
    function GetChild( index : integer ) : TMedaViewable ; virtual ;
    function GetChildCount : integer ; virtual ;
    function GetText( aColumn : integer ) : string ; virtual ;
    function GetIcon : TIconType ; virtual ;
    function GetColor : TGPColor ; virtual ;
    function CanEdit( aColumn : integer ) : boolean ; virtual ;
    function CheckType : TCheckType ; virtual ;
    procedure Moving( aNew : TGPPointF ) ; virtual ;
    function IsPlaced : boolean ; virtual ;
    function Show : TPoint ; virtual ;
    property Expanded : boolean read fExpanded write fExpanded ;
    procedure Invalidate ; virtual ;
  public
    property PopupMenu : TPopupMenu read GetPopupMenu ;
  public
    Alive : boolean ;
    procedure Mark ; virtual ;
  public
    constructor Create ;
    procedure AfterConstruction ; override ;
    function Accept( Visitor : TObject ) : TObject ; virtual ;

    property Node : PVirtualNode read FNode write SetNode ;
    property VST : TBaseVirtualTree read FVST write SetVST ;

    property ID : TGUID read fHandle write SetHandle ;
    property IDAsString : string read GetGUIDAsString write SetGUIDAsString ;
  end ;

  TMedaViewableArray = array of TMedaViewable ;

  PTreeData = ^TTreeData ;
  TTreeData = record
    aObject : TMedaViewable ;
  end ;

  TMedaPoint = class
  private
    fValue : TGPPointF ;
    procedure SetValue( const Value : TGPPointF ) ;
  public
    property Value : TGPPointF read fValue write SetValue ;
  end ;

  TMedaWirePoints = class( TObjectList )
  private
  public
    procedure AddPoint( aPoint : TGPPointF ) ;
    procedure DeletePoint( aPoint : TGPPointF ) ;
  end ;

  TMedaAbstractPlace = class( TMedaViewable )
  private
    function GetActive : boolean ;
  public
    property Active : boolean read GetActive ;
    function Center( aRect : TGPRectF ) : TPoint ; virtual ; abstract ;
  end ;

  TMedaHelper = class
  end;

  TMedaLayers = array[ TMedaLayerType ] of TMedaAbstractPlace ;

  TMemento = class
  private
    //      fOwner : TMedaViewable ;
  public
    procedure Undo ; virtual ; abstract ;
    procedure Redo ; virtual ; abstract ;
  end ;

  TMedaTransform = record
    Position : TGPPointF ;
    Rotation : integer ;
    Mirror : boolean ;
  end ;

  TMedaGraphicsType = ( mgtNone, mgtSchematics, mgtPCB, mgtMechnical, mgtGerber ) ;

  TMedaGraphics = class( TGPGraphics )
  private
    { Private declarations }
    fMemGraphics : TGPGraphics ;
    fRectVW : TGPRectF ;
    fOffset : TGPPointF ;
    fHitPoint : TGPPointF ;
    function GetShowPadNumbers : boolean ;
    function GetShowLabels : boolean ;
  protected
    { Protected declarations }
  public
    { Public declarations }
    property Offset : TGPPointF read fOffset write fOffset ;
    property View : TGPRectF read fRectVW write fRectVW ;
    property MemGraphics : TGPGraphics read fMemGraphics write fMemGraphics ;
    property HitPoint : TGPPointF read fHitPoint write fHitPoint ;
    property ShowPadNumbers : boolean read GetShowPadNumbers ;
    property ShowLabels : boolean read GetShowLabels ;
  end ;

  TObjectFactory = class
  private
    fObjects : TObjectList ;
  public
    constructor Create ;
    destructor Destroy ; override ;
    procedure Clear ;
    function Count : integer ;
    procedure Add( aObject : TMedaViewable ) ;
    procedure Collect( Roots : array of TMedaViewable ) ;
  end ;

  TCursorTypes = (
    crHandOpen = 51,
    crHandClosed = 52,
    crHandPoint = 53,
    crLinkPoint = 54,
    crDrawWand = 55,
    crLinkQuest = 56
    ) ;

var
  ObjectFactory     : TObjectFactory ;
  nullGUID          : TGUID ;

const
  cSchGrid          = 10 ;
  cSchGrid2         = cSchGrid * cSchGrid ;
  cPageWidth        = 297 * cSchGrid div 2 ;
  cPageHeight       = 210 * cSchGrid div 2 ;

  cBoxWidth         = cPageWidth div 4 ;
  cBoxHeight        = cSchGrid * 13 ;

  cPCBGrid          = 10 ;

  //    drHorizontal    = [ drEast, drWest ] ;
  //    drVertical      = [ drNorth, drSouth ] ;

  CopperLayerSet    =
    [ lcComponent, lcGround, lcInner0, lcInner1, lcInner2, lcInner3, lcPower, lcSolder ] ;

  aclWhite          : TGPColor = $FFFFFFFF ;

  aclBackSch        : TGPColor = $FFF0FFF0 ;
  aclBackSchSel     : TGPColor = $FFFFF0FF ;
  aclGridSch0       : TGPColor = $30C0C0C0 ;
  aclGridSch1       : TGPColor = $50C0C0C0 ;
  aclGridSch2       : TGPColor = $A0C0C0C0 ;

  aclBackPCB        : TGPColor = $FF204020 ;
  aclBackPCBSel     : TGPColor = $C0404040 ;
  aclGridPCB0       : TGPColor = $40606060 ;
  aclGridPCB1       : TGPColor = $50606060 ;
  aclGridPCB2       : TGPColor = $A0606060 ;

  aclRatsPenPCB     : TGPColor = $E0F04000 ;
  aclRatsPenSch     : TGPColor = $E0F04000 ;

  aclBodySch        : TGPColor = $80F0F0F0 ;
  aclBodySchSel     : TGPColor = $C0FFE0E0 ;
  aclBodyPCB        : TGPColor = $80606060 ;
  aclBodyPCBSel     : TGPColor = $C0806060 ;

  aclLine           : TGPColor = $FF404040 ;
  aclLineSel        : TGPColor = $C0E040C0 ;
  aclOutline        : TGPColor = $FF408040 ;
  aclOutlineOff     : TGPColor = $40408040 ;
  aclOutlineSel     : TGPColor = $C0E040C0 ;

  aclPin            : TGPColor = $FF4040C0 ;
  aclPinOff         : TGPColor = $404040C0 ;
  aclPinSel         : TGPColor = $C0C040C0 ;

  aclTrackTrue      : TGPColor = $C0C040C0 ;
  aclTrackMaybe     : TGPColor = $80C040C0 ;
  aclTrackFalse     : TGPColor = $40C040C0 ;

  aclTextSch        : TGPColor = $FF800000 ;
  aclTextPCB        : TGPColor = $C0C0C0C0 ;

  // project colors
  aclMedaProject    = $40FFFFFF ;
  aclMedaModules    = $40E0E0E0 ;
  aclMedaModule     = $40D0D0D0 ;
  aclMedaContainer  = $40D0D0D0 ;
  aclMedaNet        = $40C0D0C0 ;
  aclMedaPort       = $40C0B0B0 ;
  aclMedaPart       = $40D0C0C0 ;

  aclMedaBank       = $40B0B0B0 ;
  aclMedaShape      = $40B0B0B0 ;

  aclMedaPin        = $40A0A0A0 ;
  aclMedaStack      = $40A0A0A0 ;

  aclMedaLine       = $40A0A0A0 ;
  aclMedaTrack      = $40A0A0A0 ;
  aclMedaVia        = $40A0A0A0 ;
  aclMedaBuried     = $40A0C0A0 ;
  aclMedaBlind      = $40C0A0A0 ;
  aclMedaLabel      = $40A0A0A0 ;

  aclMedaSchematicView = $40B0B0B0 ;
  aclMedaPCBView    = $40B0B0B0 ;
  aclMedaPlace      = $40F0F0F0 ;

  aclMedaView       = $40B0B0B0 ;
  aclMedaObject     = $40B0B0B0 ;

function minF( a, b : single ) : single ;
function maxF( a, b : single ) : single ;
function min( a, b : integer ) : integer ;
function max( a, b : integer ) : integer ;

procedure GPInflateRect( var aRect : TGPRectF ; d : single ) ;
function GPPtInRect( aRect : TGPRectF ; aPoint : TGPPointF ) : boolean ;
procedure GPOffsetRect( var aRect : TGPRectF ; aOffset : TGPPointF ) ;
procedure GPOffsetPoint( var aPoint : TGPPointF ; aOffset : TGPPointF ) ;
function GPIntersect( r1, r2 : TGPRectF ) : boolean ;
function Distance( a, b : TGPPointF ) : single ;

function IsZeroPoint( aPoint : TGPPointF ) : boolean ;

procedure ScaleDown( var aPoint : TGPPointF ; aGrid : integer ) ;
procedure ScaleUp( var aPoint : TGPPointF ; aGrid : integer ) ; overload ;
procedure ScaleUp( var aRect : TGPRectF ; aGrid : integer ) ; overload ;

function GetPCBLayerName( aLayerType : TMedaLayerType ) : string ;
function GetPCBLayerColor( aLayerType : TMedaLayerType ) : TGPColor ;
function GetPortType( aPortType : TMedaPortType ) : string ;

function TransformToStr( aTrans : TMedaTransform ) : string ;
function StrToTransform( aStr : string ) : TMedaTransform ;
function StrToPoint( aStr : string ) : TGPPointF ;
function StrToSize( aStr : string ) : TGPSizeF ;

resourcestring
  StrMTXProjectFiles = 'MTX project files (*.mtx)|*.mtx|All files (*.*)|*.*' ;
  StrPerformanceEDASche = 'Performance EDA schematic files (*.prj, *.brd, *.' +
    'sch)|*.prj;*.brd;*.sch|All files (*.*)|*.*' ;
  StrXilinxCSVFiles = 'Xilinx CSV files (*.csv)|*.csv|All files (*.*)|*.*' ;
  StrMTXLibraryFiles = 'MTX library files (*.xml)|*.xml|All files (*.*)|*.*' ;
  StrSaveCurrentProject = 'Save current project?' ;
  StrReallyDeleteModule = 'Really delete module: "%s" and its contents?' ;
  StrECPinPakBankFiles = 'ECPinPak Bank files (*.xml)|*.xml|All files (*.*)|' +
    '*.*' ;
  StrProtoShapeFiles = 'Proto Shape files (*.xml)|*.xml|All files (*.*)|*.*' ;
  StrProtoStackFiles = 'Proto Stack files (*.xml)|*.xml|All files (*.*)|*.*' ;
  StrSpecifyAPathToTh = 'Specify a Path to the Work Directory' ;
  StrOverwrite      = 'Overwrite' ;
  StrInsert         = 'Insert' ;
  StrModified       = 'Modified' ;
  StrReadOnly       = 'ReadOnly' ;

var
  PopupVisitor      : TObject ;

implementation

uses
  uVisitor,
  uProjEDA ;

function Distance( a, b : TGPPointF ) : single ;
begin
  Result := sqrt( ( a.X - b.X ) * ( a.X - b.X ) + ( a.Y - b.Y ) * ( a.Y - b.Y ) ) ;
end ;

function GetPCBLayerName( aLayerType : TMedaLayerType ) : string ;
begin
  case aLayerType of
    lcMechanical : Result := 'Mechanical' ;
    lcTopGlue : Result := 'Top Glue' ;
    lcTopPaste : Result := 'Top Paste' ;
    lcTopSilk : Result := 'Top Silk' ;
    lcComponent : Result := 'Component' ;
    lcInner0 : Result := 'Inner 0' ;
    lcGround : Result := 'Ground' ;
    lcInner1 : Result := 'Inner 1' ;
    lcInner2 : Result := 'Inner 2' ;
    lcPower : Result := 'Power' ;
    lcInner3 : Result := 'Inner 3' ;
    lcSolder : Result := 'Solder' ;
    lcBottomSilk : Result := 'Bottom Silk' ;
    lcBottomPaste : Result := 'Bottom Paste' ;
    lcBottomGlue : Result := 'Bottom Glue' ;
  else
    Result := '<??>' ;
  end ;
end ;

function GetPCBLayerColor( aLayerType : TMedaLayerType ) : TGPColor ;
begin
  case aLayerType of
    lcComponent : Result := aclLime and $F0FFFFFF ;
    lcSolder : Result := aclRed and $F0FFFFFF ;
    lcGround : Result := aclLime or $808080 ;
    lcPower : Result := aclRed or $808080 ;
    lcInner0 : Result := aclLime or $C0C0C0 ;
    lcInner1 : Result := aclRed or $E0E0E0 ;
    lcInner2 : Result := aclLime or $E0E0E0 ;
    lcInner3 : Result := aclRed or $C0C0C0 ;
    lcTopPaste : Result := aclBlue or $C080C0 ;
    lcTopGlue : Result := aclBlue or $C090C0 ;
    lcTopSilk : Result := aclBlue or $C0A0C0 ;
    lcBottomSilk : Result := aclBlue or $A0C0C0 ;
    lcBottomGlue : Result := aclBlue or $90C0C0 ;
    lcBottomPaste : Result := aclBlue or $80C0C0 ;
  else
    Result := aclSilver and $40FFFFFF ;
  end ;
end ;

function GetPortType( aPortType : TMedaPortType ) : string ;
begin
  case aPortType of
    pntNone : Result := '<none>' ;
    pntIO : Result := 'I/O' ;
    pntIOInv : Result := 'I/O Inverted' ;
    pntIn : Result := 'Input' ;
    pntInInv : Result := 'Input Inverted' ;
    pntOut : Result := 'Input' ;
    pntOutInv : Result := 'Input Inverted' ;
    pntClock : Result := 'Pos Edge Clock' ;
    pntClockInv : Result := 'Neg Edge Clock' ;
    pntPower : Result := 'Power' ;
    pntGround : Result := 'Ground' ;
    pntAnalog : Result := 'Analog' ;
    pntPassive : Result := 'Passive' ;
    pntPortIn : Result := 'Port In' ;
    pntPortOut : Result := 'Port Out' ;
    pntPortBidir : Result := 'Port Bidir' ;
  else
    Result := '<??>' ;
  end ;
end ;

procedure GPInflateRect( var aRect : TGPRectF ; d : single ) ;
begin
  aRect.X := aRect.X - d ;
  aRect.Y := aRect.Y - d ;
  aRect.Width := aRect.Width + 2 * d ;
  aRect.Height := aRect.Height + 2 * d ;
end ;

function GPPtInRect( aRect : TGPRectF ; aPoint : TGPPointF ) : boolean ;
begin
  Result := False ;
  if aPoint.X < aRect.X then
    Exit ;
  if aPoint.Y < aRect.Y then
    Exit ;
  if aPoint.X > aRect.X + aRect.Width then
    Exit ;
  if aPoint.Y > aRect.Y + aRect.Height then
    Exit ;
  Result := True ;
end ;

procedure GPOffsetRect( var aRect : TGPRectF ; aOffset : TGPPointF ) ;
begin
  aRect.X := aRect.X + aOffset.X ;
  aRect.Y := aRect.Y + aOffset.Y ;
end ;

procedure GPOffsetPoint( var aPoint : TGPPointF ; aOffset : TGPPointF ) ;
begin
  aPoint.X := aPoint.X + aOffset.X ;
  aPoint.Y := aPoint.Y + aOffset.Y ;
end ;

function IsZeroPoint( aPoint : TGPPointF ) : boolean ;
begin
  Result := ( abs( aPoint.X ) < 10E-10 ) and ( abs( aPoint.Y ) < 10E-10 ) ;
end ;

procedure ScaleDown( var aPoint : TGPPointF ; aGrid : integer ) ;
begin
  if aGrid > 1 then begin
    aPoint.X := Round( aPoint.X / aGrid ) ;
    aPoint.Y := Round( aPoint.Y / aGrid ) ;
  end ;
end ;

procedure ScaleUp( var aPoint : TGPPointF ; aGrid : integer ) ; overload ;
begin
  aPoint.X := aPoint.X * aGrid ;
  aPoint.Y := aPoint.Y * aGrid ;
end ;

procedure ScaleUp( var aRect : TGPRectF ; aGrid : integer ) ; overload ;
begin
  aRect.X := aRect.X * aGrid ;
  aRect.Y := aRect.Y * aGrid ;
  aRect.Width := aRect.Width * aGrid ;
  aRect.Height := aRect.Height * aGrid ;
end ;

function GPIntersect( r1, r2 : TGPRectF ) : boolean ;
begin
  Result := (
    ( ( r1.X <= r2.X ) and ( r2.X <= r1.X + r1.Width ) ) or
    ( ( r2.X <= r1.X ) and ( r1.X <= r2.X + r2.Width ) )
    ) and (
    ( ( r1.Y <= r2.Y ) and ( r2.Y <= r1.Y + r1.Height ) ) or
    ( ( r2.Y <= r1.Y ) and ( r1.Y <= r2.Y + r2.Height ) )
    ) ;
end ;

function maxF( a, b : single ) : single ;
begin
  if a > b then
    Result := a
  else
    Result := b ;
end ;

function minF( a, b : single ) : single ;
begin
  if a < b then
    Result := a
  else
    Result := b ;
end ;

function max( a, b : integer ) : integer ;
begin
  if a > b then
    Result := a
  else
    Result := b ;
end ;

function min( a, b : integer ) : integer ;
begin
  if a < b then
    Result := a
  else
    Result := b ;
end ;

function TransformToStr( aTrans : TMedaTransform ) : string ;
begin
  with aTrans do
    Result := Format( '%g,%g,%d,%d', [ Position.X, Position.Y, ord( Rotation ), ord( Mirror ) ] ) ;
end ;

function StrToTransform( aStr : string ) : TMedaTransform ;
var
  S, P              : PChar ;
  term              : string ;
  i                 : integer ;
begin
  Result.Position := MakePoint( 0.0, 0.0 ) ;
  Result.Rotation := 0 ;
  Result.Mirror := False ;
  if aStr = '' then
    Exit ;

  P := PChar( aStr ) ;

  S := P ;
  while P^ <> ',' do
    inc( P ) ;
  SetString( term, S, P - S ) ;
  Result.Position.X := StrToFloat( term ) ;
  inc( P ) ;

  S := P ;
  while P^ <> ',' do
    inc( P ) ;
  SetString( term, S, P - S ) ;
  Result.Position.Y := StrToFloat( term ) ;
  inc( P ) ;

  S := P ;
  while P^ <> ',' do
    inc( P ) ;
  SetString( term, S, P - S ) ;
  i := StrToInt( term ) ;
  Result.Rotation := i ;
  inc( P ) ;

  S := P ;
  while P^ <> #0 do
    inc( P ) ;
  SetString( term, S, P - S ) ;
  i := StrToInt( term ) ;
  Result.Mirror := i <> 0 ;
end ;

function StrToPoint( aStr : string ) : TGPPointF ;
var
  S, P              : PChar ;
  term              : string ;
begin
  P := PChar( aStr ) ;
  S := P ;
  while P^ <> ',' do
    inc( P ) ;
  SetString( term, S, P - S ) ;
  Result.X := StrToFloatDef( term, 0.0 ) ;
  inc( P ) ;

  S := P ;
  while P^ <> #0 do
    inc( P ) ;
  SetString( term, S, P - S ) ;
  Result.Y := StrToFloatDef( term, 0.0 ) ;
end ;

function StrToSize( aStr : string ) : TGPSizeF ;
var
  S, P              : PChar ;
  term              : string ;
begin
  P := PChar( aStr ) ;
  S := P ;
  while P^ <> ',' do
    inc( P ) ;
  SetString( term, S, P - S ) ;
  Result.Width := StrToFloat( term ) ;
  inc( P ) ;

  S := P ;
  while P^ <> #0 do
    inc( P ) ;
  SetString( term, S, P - S ) ;
  Result.Height := StrToFloat( term ) ;
end ;

{ TMedaViewable }

function TMedaViewable.Accept( Visitor : TObject ) : TObject ;
begin
  Result := TMedaVisitor( Visitor ).VisitNode( Self ) ;
end ;

procedure TMedaViewable.AfterConstruction ;
begin
  inherited ;
  if not assigned( ObjectFactory ) then
    ObjectFactory := TObjectFactory.Create ;
  ObjectFactory.Add( Self ) ;
end ;

function TMedaViewable.CanEdit( aColumn : integer ) : boolean ;
begin
  Result := False ;
end ;

constructor TMedaViewable.Create ;
begin
  inherited ;
  fExpanded := False ;
  CreateGUID( fHandle ) ;
end ;

function TMedaViewable.GetChild( index : integer ) : TMedaViewable ;
begin
  Result := nil ;
end ;

function TMedaViewable.GetColor : TGPColor ;
begin
  Result := aclMedaObject ;
end ;

function TMedaViewable.GetGUIDAsString : string ;
begin
  Result := GUIDtoString( fHandle ) ;
end ;

function TMedaViewable.GetChildCount : integer ;
begin
  Result := 0 ;
end ;

function TMedaViewable.GetIcon : TIconType ;
begin
  Result := iconNone ;
end ;

function TMedaViewable.GetName : string ;
begin
  Result := fName ;
end ;

function TMedaViewable.GetPopupMenu : TPopupMenu ;
begin
  Result := TPopupMenu( Accept( PopupVisitor as TPopupVisitor ) ) ;
end ;

function TMedaViewable.GetSelection : TMedaState ;
begin
  Result := fSelection ;
end ;

function TMedaViewable.GetText( aColumn : integer ) : string ;
begin
  Result := '<bug>' ;
end ;

function TMedaViewable.CheckType : TCheckType ;
begin
  Result := ctNone ;
end ;

procedure TMedaViewable.Update ;
begin
end ;

procedure TMedaViewable.Invalidate ;
begin
end ;

function TMedaViewable.IsPlaced : boolean ;
begin
  Result := False ;
end ;

procedure TMedaViewable.Mark ;
begin
  Alive := True ;
end ;

procedure TMedaViewable.Moving( aNew : TGPPointF ) ;
begin
end ;

procedure TMedaViewable.SetName( const aName : string ) ;
begin
  fName := aName ;
  Invalidate ;
end ;

procedure TMedaViewable.SetNode( const Value : PVirtualNode ) ;
begin
  FNode := Value ;
end ;

procedure TMedaViewable.SetSelection( aFlag : TMedaState ) ;
begin
  fSelection := aFlag ;
  if assigned( fVST ) then begin
    case aFlag of
      triFalse : fVST.CheckState[ Node ] := csUncheckedNormal ;
      triMaybe : fVST.CheckState[ Node ] := csMixedNormal ;
      triTrue : fVST.CheckState[ Node ] := csCheckedNormal ;
    end ;
  end ;
end ;

procedure TMedaViewable.SetVST( const Value : TBaseVirtualTree ) ;
begin
  fVST := Value ;
end ;

function TMedaViewable.Show : TPoint ;
begin
  Result := Point( 0, 0 ) ;
end ;

procedure TMedaViewable.SetGUIDAsString( const Value : string ) ;
begin
  fHandle := nullGUID ;
  if Pos( '{', Value ) > 0 then
    fHandle := StringtoGUID( Value ) ;
end ;

procedure TMedaViewable.SetHandle( aHandle : TGUID ) ;
begin
  fHandle := aHandle ;
end ;

{ TMedaAbstractPlace }

function TMedaAbstractPlace.GetActive : boolean ;
begin
  Result := GetSelection = triTrue ;
end ;

{ TMedaGraphics }

function TMedaGraphics.GetShowLabels : boolean ;
begin
  Result := minF( fRectVW.Width, fRectVW.Height ) < 2000 ;
end ;

function TMedaGraphics.GetShowPadNumbers : boolean ;
begin
  Result := minF( fRectVW.Width, fRectVW.Height ) < 400 ;
end ;

{ TObjectFactory }

constructor TObjectFactory.Create ;
begin
  inherited ;
  fObjects := TObjectList.Create( True ) ;
end ;

destructor TObjectFactory.Destroy ;
begin
  fObjects.Free ;
  inherited ;
end ;

procedure TObjectFactory.Clear ;
begin
  fObjects.Clear ;
end ;

function TObjectFactory.Count : integer ;
begin
  Result := fObjects.Count ;
end ;

procedure TObjectFactory.Add( aObject : TMedaViewable ) ;
begin
  fObjects.Add( aObject ) ;
end ;

procedure TObjectFactory.Collect( Roots : array of TMedaViewable ) ;
var
  i                 : integer ;
begin
  // erase marks
  for i := 0 to fObjects.Count - 1 do
    TMedaViewable( fObjects[ i ] ).Alive := False ;
  // mark all alive
  for i := 0 to length( Roots ) - 1 do
    if assigned( Roots[ i ] ) then
      Roots[ i ].Mark ;
  // sweep all unmarked
  for i := fObjects.Count - 1 downto 0 do
    if not TMedaViewable( fObjects[ i ] ).Alive then
      fObjects.Delete( i ) ;
end ;

{ TMedaWirePoints }

procedure TMedaWirePoints.AddPoint( aPoint : TGPPointF ) ;
var
  iPoint            : TMedaPoint ;
begin
  iPoint := TMedaPoint.Create ;
  iPoint.Value := aPoint ;
  Add( iPoint ) ;
end ;

procedure TMedaWirePoints.DeletePoint( aPoint : TGPPointF ) ;
var
  i                 : integer ;
begin
  for i := Count - 1 to 0 do
    if ( aPoint.X = TMedaPoint( Items[ i ] ).Value.X ) and
      ( aPoint.Y = TMedaPoint( Items[ i ] ).Value.Y ) then
      Delete( i ) ;
end ;

{ TMedaPoint }

procedure TMedaPoint.SetValue( const Value : TGPPointF ) ;
begin
  fValue := Value ;
end ;

initialization
  // Loads Custom Cursors
  Screen.Cursors[ ord( crHandOpen ) ] := LoadCursor( HInstance, 'HANDOPEN' ) ;
  Screen.Cursors[ ord( crHandClosed ) ] := LoadCursor( HInstance, 'HANDCLOSED' ) ;
  Screen.Cursors[ ord( crHandPoint ) ] := LoadCursor( HInstance, 'HANDPOINT' ) ;
  Screen.Cursors[ ord( crLinkPoint ) ] := LoadCursor( HInstance, 'LINKPOINT' ) ;
  Screen.Cursors[ ord( crLinkQuest ) ] := LoadCursor( HInstance, 'LINKQUEST' ) ;
  Screen.Cursors[ ord( crDrawWand ) ] := LoadCursor( HInstance, 'DRAWWAND' ) ;

finalization
  if assigned( ObjectFactory ) then
    ObjectFactory.Free ;

end.

